home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Programming Languages Suite
/
ProgLangD.iso
/
TURBOPASCAL WIN
/
OWLDEMOS.PAK
/
POPUP.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-06-08
|
5KB
|
178 lines
{************************************************}
{ }
{ Turbo Pascal for Windows }
{ Demo program }
{ Copyright (c) 1991 by Borland International }
{ }
{************************************************}
program Popup;
uses WinTypes, WinProcs, Strings, WObjects;
{$R POPUP}
const
cm_Window = 100;
type
TSubWinType = (sw_Child, sw_PopParent, sw_PopNoParent);
PSubWindow = ^TSubWindow;
TSubWindow = object(TWindow)
SubWinType: TSubWinType;
constructor Init(AParent: PWindowsObject; ASubWinType: TSubWinType);
destructor Done; virtual;
procedure Paint(PaintDC: HDC; var PaintStruct: TPaintStruct); virtual;
end;
PMainWindow = ^TMainWindow;
TMainWindow = object(TWindow)
constructor Init(ATitle: PChar);
procedure ShowSubWindow(AParent: PWindowsObject;
ASubWinType: TSubWinType);
procedure WMInitMenu(var Msg: TMessage);
virtual wm_First + wm_InitMenu;
procedure CMChild(var Msg: TMessage);
virtual cm_First + cm_Window + Ord(sw_Child);
procedure CMPopParent(var Msg: TMessage);
virtual cm_First + cm_Window + Ord(sw_PopParent);
procedure CMPopNoParent(var Msg: TMessage);
virtual cm_First + cm_Window + Ord(sw_PopNoParent);
end;
TPopupApp = object(TApplication)
procedure InitMainWindow; virtual;
end;
const
SubWinPtr: array[TSubWinType] of PSubWindow = (nil, nil, nil);
SubWinTitle: array[TSubWinType] of PChar = (
'Child Window', 'Popup with Parent', 'Popup without Parent');
SubWinStyle: array[TSubWinType] of Longint = (
ws_Child or ws_OverlappedWindow or ws_Visible,
ws_Popup or ws_OverlappedWindow or ws_Visible,
ws_Popup or ws_OverlappedWindow or ws_Visible);
SubWinPos: array[TSubWinType] of TPoint = (
(X: 10; Y: 10), (X: 34; Y: 72), (X: 54; Y: 92));
SubWinText: array[TSubWinType] of PChar = (
'Child windows cannot be moved outside their parent window. When ' +
'minimized, a child window''s icon resides within the parent ' +
'window.',
'Popup windows can be moved outside their parent window. A popup ' +
'with a parent is always displayed in front of the parent, ' +
'even when the parent is focused. To test this, click on the ' +
'parent window. When minimized, popup icons reside on the desktop.',
'Popup windows can be moved outside their parent window. A popup ' +
'without a parent allows the parent to be brought to the front ' +
'when focused. To test this, click on the parent window. When ' +
'minimized, popup icons reside on the desktop.');
var
PopupApp: TPopupApp;
{ TSubWindow }
constructor TSubWindow.Init(AParent: PWindowsObject;
ASubWinType: TSubWinType);
begin
TWindow.Init(AParent, SubWinTitle[ASubWinType]);
Attr.Style := SubWinStyle[ASubWinType];
Attr.X := SubWinPos[ASubWinType].X;
Attr.Y := SubWinPos[ASubWinType].Y;
Attr.W := 300;
Attr.H := 150;
SubWinType := ASubWinType;
end;
destructor TSubWindow.Done;
begin
TWindow.Done;
SubWinPtr[SubWinType] := nil;
end;
procedure TSubWindow.Paint(PaintDC: HDC; var PaintStruct: TPaintStruct);
var
S: PChar;
R: TRect;
begin
GetClientRect(HWindow, R);
InflateRect(R, -2, 0);
S := SubWinText[SubWinType];
DrawText(PaintDC, S, StrLen(S), R, dt_WordBreak);
end;
{ TMainWindow }
constructor TMainWindow.Init(ATitle: PChar);
begin
TWindow.Init(nil, ATitle);
Attr.X := 0;
Attr.Y := 0;
Attr.W := 400;
Attr.H := 215;
Attr.Menu := LoadMenu(HInstance, 'Menu');
end;
procedure TMainWindow.ShowSubWindow(AParent: PWindowsObject;
ASubWinType: TSubWinType);
begin
if SubWinPtr[ASubWinType] = nil then
SubWinPtr[ASubWinType] := PSubWindow(Application^.MakeWindow(
New(PSubWindow, Init(AParent, ASubWinType))))
else
SetFocus(SubWinPtr[ASubWinType]^.HWindow);
end;
procedure TMainWindow.WMInitMenu(var Msg: TMessage);
var
Index: TSubWinType;
MenuState: Word;
begin
for Index := sw_Child to sw_PopNoParent do
begin
if SubWinPtr[Index] = nil then
MenuState := mf_Unchecked else
MenuState := mf_Checked;
CheckMenuItem(Attr.Menu, cm_Window + Ord(Index), MenuState);
end;
end;
procedure TMainWindow.CMChild(var Msg: TMessage);
begin
ShowSubWindow(@Self, sw_Child);
end;
procedure TMainWindow.CMPopParent(var Msg: TMessage);
begin
ShowSubWindow(@Self, sw_PopParent);
end;
procedure TMainWindow.CMPopNoParent(var Msg: TMessage);
begin
ShowSubWindow(nil, sw_PopNoParent);
end;
{ TPopupApp }
procedure TPopupApp.InitMainWindow;
begin
MainWindow := New(PMainWindow, Init('Parent Window'));
end;
{ Main program }
begin
PopupApp.Init('Popup');
PopupApp.Run;
PopupApp.Done;
end.